{-
 -  Separ, Type/ClsType.hs
 -
 -  Copyright (c) 2010 Dariusz Leniowski. All Rights Reserved.
 -
 -  Redistribution and use in source and binary forms, with or without 
 -  modification, are permitted provided that the following conditions 
 -  are met:
 -
 -  1. Redistributions of source code must retain the above copyright 
 -     notice, this list of conditions and the following disclaimer.
 -
 -  2. Redistributions in binary form must reproduce the above copyright 
 -     notice, this list of conditions and the following disclaimer 
 -     in the documentation and/or other materials provided with 
 -     the distribution.
 -
 -  3. The name of the author may not be used to endorse or promote 
 -     products derived from this software without specific prior 
 -     written permission.
 -
 -  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 
 -  "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 
 -  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 
 -  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
 -  THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, 
 -  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 
 -  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 
 -  OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 
 -  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 
 -  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 
 -  IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 
 -  POSSIBILITY OF SUCH DAMAGE.
 -
 -}

-- Module ClsType
-- Autogenerated, do not edit

module Type.ClsType where

import qualified GHC.Read as GR
import qualified Text.Read.Lex as Lex
import qualified Text.ParserCombinators.ReadPrec as RP
import qualified Data.List as List
import Data.Bits

data ClsType = C Int Integer deriving (Eq,Ord)

clsN :: Int
clsN = 6
clsNSpecial :: Int
clsNSpecial = 3

clsGetAllI :: [Int]
clsGetAllI = [1..6]

clsGetAll :: [ClsType]
clsGetAll = map clsIToCls clsGetAllI

clsThingI :: Int
clsThingI = 1
clsThing :: ClsType
clsThing = (C clsThingI 0)
clsNothingI :: Int
clsNothingI = 2
clsNothing :: ClsType
clsNothing = (C clsNothingI 0)
clsNothingThingI :: Int
clsNothingThingI = 3
clsNothingThing :: ClsType
clsNothingThing = (C clsNothingThingI 0)
clsThingNothingI :: Int
clsThingNothingI = 4
clsThingNothing :: ClsType
clsThingNothing = (C clsThingNothingI 0)
clsUnknownI :: Int
clsUnknownI = 5
clsUnknown :: ClsType
clsUnknown = (C clsUnknownI 0)

clsIsThing :: ClsType -> Bool
clsIsThing (C 1 0) = True
clsIsThing _ = False

clsIsNothing :: ClsType -> Bool
clsIsNothing (C 2 0) = True
clsIsNothing (C 0 (-1)) = True
clsIsNothing (C 0 7) = True
clsIsNothing _ = False

clsIsNothingThing :: ClsType -> Bool
clsIsNothingThing (C 3 0) = True
clsIsNothingThing (C 0 6) = True
clsIsNothingThing _ = False

clsIsThingNothing :: ClsType -> Bool
clsIsThingNothing (C 4 0) = True
clsIsThingNothing (C 0 1) = True
clsIsThingNothing _ = False

clsIsUnknown :: ClsType -> Bool
clsIsUnknown (C 5 0) = True
clsIsUnknown (C 0 2) = True
clsIsUnknown _ = False

clsIToCls :: Int -> ClsType
clsIToCls i = (C i 0)

clsIToE :: Int -> Integer
clsIToE 0 = error $ "illegal classI: 0"
clsIToE 1 = 0
clsIToE 2 = 7
clsIToE 3 = 6
clsIToE 4 = 1
clsIToE 5 = 2
clsIToE 6 = 4
clsIToE i = error $ "illegal classI: " ++ show i

clsIBit :: Int -> Int
clsIBit i = i - 4

clsEToIs :: Integer -> [Int]
clsEToIs 0 = [clsThingI]
clsEToIs (-1) = [clsNothingI]
clsEToIs 7 = [clsNothingI]
clsEToIs 6 = [clsNothingThingI]
clsEToIs e = opt (drop clsNSpecial clsGetAllI) e [] -- drop for thing and nothing
	where
		opt _ 0 acc = acc
		opt [] j _ = error $ "clsEToString illegal classE: " ++ show j
		opt _ j _ | j < 0 = error "clsEToString illegal argument"
		opt (i:is) j acc = 
			if testBit j (clsIBit i) then
				let j' = j .&. complement (clsIToE i) in 
					-- j >= 0, so j' >= 0
				opt is j' (i:acc)
			else opt is j acc

clsEToCls :: Integer -> ClsType
clsEToCls 0 = (C 1 0)
clsEToCls (-1) = (C 2 0)
clsEToCls (7) = (C 2 0)
clsEToCls (6) = (C 3 0)
clsEToCls 1 = (C 4 0)
clsEToCls 2 = (C 5 0)
clsEToCls 4 = (C 6 0)
clsEToCls e = (C 0 e)

------------------------------------------
--  SHOW and READ
------------------------------------------

clsToString :: ClsType -> String
clsToString (C i 0) = clsIToString i
clsToString (C 0 e) = clsEToString e
clsToString (C i e) = "(C " ++ show i ++ " " ++ show e ++ ")"

clsIToString :: Int -> String
clsIToString 0 = "(C 0 0)"
clsIToString 1 = "Thing"
clsIToString 2 = "Nothing"
clsIToString 4 = "ThingNothing"
clsIToString 3 = "NothingThing"
clsIToString 5 = "Unknown"
clsIToString 6 = "Number"
clsIToString i = "(C " ++ show i ++ " 0)"

clsEToString :: Integer -> String
clsEToString e = show $ map clsIToCls $ clsEToIs e 	

instance Show ClsType where
	show c = clsToString c

clsIFromString :: String -> RP.ReadPrec Int
clsIFromString "Thing" = return 1
clsIFromString "Nothing" = return 2
clsIFromString "NothingThing" = return 3
clsIFromString "ThingNothing" = return 4
clsIFromString "Unknown" = return 5
clsIFromString "Number" = return 6
clsIFromString _ = RP.pfail

clsToE :: ClsType -> Integer
clsToE (C 0 0) = error $ "illegal class: (C 0 0)"
clsToE (C i 0) = clsIToE i
clsToE (C 0 e) = e

clsNot :: ClsType -> ClsType
clsNot (C i1 0) = clsNot (C 0 $ clsIToE i1)
clsNot (C 0 e1) = 
	let e3 = foldl clearBit (clsIToE clsNothingI) $ map clsIBit $ clsEToIs e1 in
	let f e i =	
		let ei = clsIToE i in
		if ei .&. e == ei then e
		else clearBit e (clsIBit i)
	in clsEToCls $ foldl f e3 $ drop clsNSpecial clsGetAllI

clsDomainI :: Int -> Integer
clsDomainI i1 =
	let e1 = clsIToE i1 in 
	let f e i = 
		let ei = clsIToE i in
		if ei .&. e1 == e1 then e .|. ei else e
	in foldl f e1 $ drop clsNSpecial clsGetAllI
clsDomain :: ClsType -> ClsType
clsDomain (C i1 0) = clsEToCls $ clsDomainI i1
clsDomain (C 0 e1) = 
	clsEToCls $ List.foldl1 (.|.) $ map clsDomainI (clsEToIs e1)

clsInf ls = clsEToCls $ List.foldl1 (.|.) $ map clsToE ls
clsSup ls = clsEToCls $ List.foldl1 (.&.) $ map clsToE ls

instance Read ClsType where
	readPrec = GR.parens $ readPrecOne RP.+++ readPrecList where
		mod x = do
			str <- RP.look
			case str of
				('~':_) -> do 
					'~' <- RP.get
					fmap clsNot $ GR.parens $ mod x
				('@':_) -> do
					'@' <- RP.get
					fmap clsDomain $ GR.parens $ mod x
				_ -> x
		readPrecOne = mod $ do
			Lex.Ident s <- GR.lexP
			i <- clsIFromString s
			return $ clsIToCls i
		readPrecList = mod $ do
			ls <- GR.list readPrecOne
			return $ clsInf ls

clsFromString :: String -> ClsType
clsFromString s = read s

